home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 06 - 1990 / 06.08 Aug 90 / Pearl Source / Solar.lisp (Pearl source) < prev   
Encoding:
Text File  |  1988-06-12  |  9.6 KB  |  257 lines  |  [TEXT/PERL]
  1.  
  2. ;;; Sample program for "Objects in Pearl Lisp"
  3. ;;; by Stephen E. Miner
  4. ;;; Written in Pearl Lisp 1.01
  5. ;;; File:    Solar.lisp
  6. ;;; Version: 1.0
  7.  
  8.  
  9. ;;; NOTE:  The "object-variable" declarations prevent the compiler from
  10. ;;;        issuing warnings about free variables.
  11.  
  12.  
  13. ;;; Set up environment
  14. (eval-when (eval load compile)
  15.   (require 'quickdraw))
  16. (eval-when (eval compile)
  17.   (require 'records))
  18.  
  19.  
  20. ;;; Global variables
  21. (defvar *solar-num* 0 "Global counter for numbering windows.")
  22. (defvar *time* 0 "Global variable holding the time that is displayed.")
  23. (defvar *stop-flag* t "Non-nil if the simulation should stop.")
  24.  
  25.  
  26. ;;; The planet class
  27. (defobject *planet* nil)
  28.  
  29. (defobfun (exist *planet*) (init-list)
  30.   "Initializes an instance of the *planet* class according to INIT-LIST.
  31. Useful init keywords are :period, :size, :pattern, :radius and :center.
  32. The return value is undefined."
  33.   (have 'period (getf init-list :period 25))
  34.   (have 'size (getf init-list :size 3))
  35.   (have 'pattern (getf init-list :pattern *black-pattern*))
  36.   (have 'x 0)
  37.   (have 'y 0)
  38.   (have 'satellites nil)
  39.   (let ((center (getf init-list :center))
  40.         (me (self)))           ;(self) returns the object being defined
  41.     (have 'radius (getf init-list :radius (if center 25 0)))
  42.     (when center
  43.       (ask center (add-satellite me)))))
  44.  
  45. (defobfun (add-satellite *planet*) (sat)
  46.   "Add SAT to the planet's list of satellites and return the new list."
  47.   (declare (object-variable satellites))
  48.   (setq satellites (cons sat satellites)))
  49.  
  50. (defobfun (update-system *planet*) (time cx cy)
  51.   "Update the x and y coordinates of the planet according to the 
  52. TIME and the offsets CX and CY which should be the x and y coordinates of 
  53. the center of the planet's orbit.  Then recursively send the update-system 
  54. message to the satellites of the planet using the new x and y coordinates
  55. as the offsets.  The return value is undefined." 
  56.   (declare (object-variable period radius x y satellites))
  57.   (let* ((theta (* 2 pi (/ time period)))
  58.          (new-x (+ cx (round (* radius (cos theta)))))
  59.          (new-y (+ cy (round (* radius (sin theta))))))
  60.     (setq x new-x y new-y)
  61.     (dolist (sat satellites)
  62.       (ask sat (update-system time new-x new-y)))))
  63.  
  64.  
  65.  
  66. ;;; The planet objects (the numbers are not accurate, but they produce
  67. ;;; a reasonable display.)
  68.  
  69. (defparameter *sun* (oneof *planet* :center nil :size 11 
  70.                            :pattern *light-gray-pattern*))
  71.   
  72. (defparameter *mercury* (oneof *planet* :radius 20 :center *sun* :period 12 
  73.                                :size 3 :pattern *dark-gray-pattern*))
  74.  
  75. (defparameter *venus* (oneof *planet* :radius 35 :center *sun* :period 32 
  76.                              :size 5 :pattern *dark-gray-pattern*))
  77.  
  78. (defparameter *earth* (oneof *planet* :radius 60 :center *sun* :period 52
  79.                              :size 6 :pattern *gray-pattern*))
  80.  
  81. (defparameter *moon* (oneof *planet* :radius 10 :center *earth* :period 4
  82.                             :size 2))
  83.  
  84. (defparameter *mars* (oneof *planet* :radius 85 :center *sun* :period 90
  85.                              :size 5 :pattern *dark-gray-pattern*))
  86.  
  87.  
  88.  
  89. ;;; The solar window class
  90. (defobject *solar-window* *window*)
  91.  
  92. (defobfun (exist *solar-window*) (init-list)
  93.   "Initializes an instance of the *solar-window* according to the INIT-LIST.
  94. Useful keywords are :center which specifies the gravitational center of the
  95. displayed system and :view which specifies the planet that controls the
  96. viewpoint of the display.  The return value is undefined."
  97.   (declare (object-variable center))
  98.   (usual-exist (init-list-default init-list 
  99.                                   :window-title "Solar System"
  100.                                   :window-size #@(250 250)
  101.                                   :window-show nil))
  102.   ;;don't show the window until the window is fully initialized
  103.   (have 'center (getf init-list :center))
  104.   (have 'view (getf init-list :view center))
  105.   (center-origin)
  106.   (window-show))
  107.  
  108.  
  109. ;;; The event system will automatically ask windows to handle certain events.
  110. ;;; Specialized object functions for handling these events are defined below.
  111.  
  112. (defobfun (window-draw-contents *solar-window*) ()
  113.   "Specialized version of window-draw-contents called by the event system
  114. whenever part of the window needs to be redrawn.  The return value is
  115. undefined."
  116.   (declare (object-variable center view x y))
  117.   (erase-window)
  118.   (usual-window-draw-contents)
  119.   (draw-system center (- (ask view x)) (- (ask view y))))
  120.  
  121. (defobfun (window-zoom-event-handler *solar-window*) (message)
  122.   "Specialized version of window-zoom-event-handler which is called by the
  123. operating system when the user clicks in the zoom box.  The MESSAGE is passed
  124. on to the usual-window-zoom-event-handler.  This version also recenters the 
  125. origin.  The return value is undefined."
  126.   (usual-window-zoom-event-handler message)
  127.   (center-origin))
  128.  
  129. (defobfun (set-window-size *solar-window*) (h &optional v)
  130.   "Specialized version of set-window-size.  Sets the size of the window
  131. according to horizontal and vertical dimensions, H and V.  H and V are 
  132. either two integers or H is taken as a point if V is nil.  Also recenters 
  133. the origin and redraws the window.  Returns the window's new size as a point."
  134.   (prog1
  135.     (usual-set-window-size h v)
  136.     (center-origin)
  137.     (window-draw-contents)))
  138.  
  139. (defobfun (center-origin *solar-window*) ()
  140.   "Adjust the origin to the center of the window.  Returns the window's new 
  141. upper lefthand corner as a point."
  142.   (let ((pt (window-size)))
  143.     (set-origin (floor (point-h pt) -2)
  144.                 (floor (point-v pt) -2))))
  145.  
  146. (defobfun (draw-system *solar-window*) (planet x-off y-off)
  147.   "Draw the PLANET and its satellites in the window after adding X-OFF
  148. and Y-OFF to the planet's x and y coordinates.  The return value is undefined."
  149.   (declare (object-variable x y size pattern satellites))
  150.   (let ((x0 (+ (ask planet x) x-off))
  151.         (y0 (+ (ask planet y) y-off))
  152.         (size (ask planet size)))
  153.     ;;allocate a temporary rectangle for graphics calls
  154.     (rlet ((rec :rect :top (- x0 size) :left (- y0 size)
  155.                 :bottom (+ x0 size) :right (+ y0 size)))
  156.       (fill-oval (ask planet pattern) rec)
  157.       (frame-oval rec)))
  158.   ;;draw the satellites
  159.   (dolist (sat (ask planet satellites))
  160.     (draw-system sat x-off y-off)))
  161.  
  162. (defobfun (erase-window *solar-window*) ()
  163.   "Erase the contents of the window.  The return value is undefined."
  164.   ;;rref access the Macintosh record and in this case returns the window's
  165.   ;; portrect.  See the Pearl Lisp documentation for more information
  166.   ;; about records.
  167.   (declare (object-variable wptr))
  168.   (erase-rect (rref wptr window.portrect)))
  169.  
  170.  
  171. ;;; Menu action functions
  172.  
  173. (defun new-solar (view-planet title)
  174.   "Create a new solar window with VIEW-PLANET determining the point of 
  175. view and the TITLE string used as base for the window title.  The global 
  176. *solar-num* is incremented and appended to the window title to ease 
  177. identification.  Returns the new window object."
  178.   (setq *solar-num* (+ *solar-num* 1))
  179.   (oneof *solar-window* :window-title (format nil "~A ~A" title *solar-num*)
  180.          :center *sun*
  181.          :view view-planet))
  182.  
  183. (defun exit-solar ()
  184.   "Close all the solar windows and deinstall the menu.  The return value
  185. is undefined."
  186.   (dolist (w (windows *solar-window*)) 
  187.     (ask w (window-close)))
  188.   (ask *solar-menu* (menu-deinstall)))
  189.  
  190. (defun run-loop ()
  191.   "Run the simulation until the global *stop-flag* is true.  This function
  192. also manages the solar menu."
  193.   (setq *stop-flag* nil)
  194.   (ask *stop-item* (set-menu-item-check-mark nil))
  195.   (ask *run-item* (set-menu-item-check-mark t))
  196.   (loop
  197.     (let ((wlist (windows *solar-window*))) ;list of all *solar-window*'s
  198.       (when (or *stop-flag* (null wlist))   ;check for end of simulation
  199.         (ask *run-item* (set-menu-item-check-mark nil))
  200.         (ask *stop-item* (set-menu-item-check-mark t))
  201.         (return))
  202.       (setq *time* (+ 1 *time*))
  203.       (ask *sun* (update-system *time* 0 0)) ;updates all the x and y coords
  204.       (dolist (w wlist)
  205.         (ask w (when (ownp 'wptr)   ;protect against close-box
  206.                  (window-draw-contents)))))))   ;redraw the window
  207.  
  208.  
  209. ;;; The menu items
  210.  
  211. (defparameter *new-helio-item* 
  212.   (oneof *menu-item* :menu-item-title "New Helio"
  213.          :menu-item-action '(new-solar *sun* "Heliocentric")))
  214.  
  215. (defparameter *new-geo-item* 
  216.   (oneof *menu-item* :menu-item-title "New Geo"
  217.          :menu-item-action '(new-solar *earth* "Geocentric")))
  218.  
  219. (defparameter *new-luna-item* 
  220.   (oneof *menu-item* :menu-item-title "New Luna"
  221.          :menu-item-action '(new-solar *moon* "Lunacentric")))
  222.  
  223. (defparameter *run-item* 
  224.   (oneof *menu-item* :menu-item-title "Run"
  225.          :menu-item-action '(when *stop-flag* (eval-enqueue '(run-loop)))))
  226.                     
  227. (defparameter *stop-item* 
  228.   (oneof *menu-item* :menu-item-title "Stop"
  229.          :menu-item-action '(setq *stop-flag* t)))
  230.  
  231. (defparameter *exit-item* 
  232.   (oneof *menu-item* :menu-item-title "Exit"
  233.          :menu-item-action 
  234.          '(progn
  235.             (setq *stop-flag* t)
  236.             (eval-enqueue '(exit-solar)))))
  237. ;;The eval-enqueue makes sure that we wait for the run-loop to finish
  238. ;; before we exit.
  239.  
  240. (defparameter *solar-menu* 
  241.   (oneof *menu* :menu-title "Solar"
  242.          :menu-items (list *new-helio-item*
  243.                            *new-geo-item*      
  244.                            *new-luna-item*
  245.                            (oneof *menu-item* :menu-item-title "-"
  246.                                   :disabled t)
  247.                            *run-item*
  248.                            *stop-item*
  249.                            *exit-item*)))
  250.  
  251.  
  252. ;;; Install the menu
  253. (ask *run-item* (set-menu-item-check-mark (not *stop-flag*)))
  254. (ask *stop-item* (set-menu-item-check-mark *stop-flag*))                          
  255. (ask *solar-menu* (menu-install))
  256.  
  257.